unit uDZXMLSerializer;

interface

uses
  SysUtils, Classes, Windows, XMLIntf, XMLDoc, uDZSysUtils, uDZBase64, uDZStr, uDZStream,
  uDZSerializer;

type
  TDzXMLClassReader = class(TDzClassReader)
  private
    fDocument: IXMLDocument;
    fRootObject: IXMLNode;
    procedure SetObjectNode(const Value: IXMLNode);
  public
    function BeginReadRootObject(out Name: TNameString): Boolean; override;
    function BeginReadObject(const Name: TNameString): Boolean; override;
    procedure EndReadObject; override;
    function BeginReadList(out Count: Integer): Boolean; override;
    procedure EndReadList; override;
    function BeginReadListItem(Index: Integer): Boolean; override;
    function EndReadListItem: Boolean; override;
    procedure ReadPropList(props: TStrings); override;
    function ReadAnsiChar(const Name: TNameString; out Value: AnsiChar): Boolean; override;
    function ReadWideChar(const Name: TNameString; out Value: WideChar): Boolean; override;
    function ReadDWord(const Name: TNameString; out Value: Integer): Boolean; override;
    function ReadQWord(const Name: TNameString; out Value: Int64): Boolean; override;
    function ReadFloat(const Name: TNameString; out Value: Extended): Boolean; override;

    function ReadAnsiStr(const Name: TNameString;
      out Value: AnsiString): Boolean; override;

    function ReadWideStr(const Name: TNameString;
      out Value: WideString): Boolean; override;

    function ReadUnicodeStr(const Name: TNameString;
      out Value: WideString): Boolean; override;

    function ReadAnsiStrListItem(Index: Integer; out Value: AnsiString;
      out More: Boolean): Boolean; override;

    function ReadWStrListItem(Index: Integer; out Value: WideString;
      out More: Boolean): Boolean; override;

    function ReadUStrListItem(Index: Integer; out Value: WideString;
      out More: Boolean): Boolean; override;

    function ReadPointer(const Name: TNameString; Buf: Pointer;
      var Len: Integer): Boolean; override;
      
    procedure LoadFromStream(Input: TStream);
  public
    property ObjectNode: IXMLNode read fRootObject write SetObjectNode;
  end;

  TDzXMLClassWriter = class(TDzClassWriter)
  private
    fEncoding: AnsiString;
    fCodePage: Integer;
    fDeclaration: Boolean;
    procedure WriteDeclaration;
    procedure StreamWriteByte(value: Byte);
    procedure StreamWritePureAnsi(const str: AnsiString); overload;
    procedure StreamWritePureAnsi(const str: PAnsiChar; len: Integer); overload;
    procedure StreamWriteAnsi(const str: AnsiString); overload;
    procedure StreamWriteUnicode(const str: WideString); overload;
    procedure StreamWriteAnsi(const str: PAnsiChar; len: Integer); overload;
    procedure StreamWriteUnicode(const str: PWideChar; len: Integer); overload;
    procedure StreamWriteTag(const str: TNameString; slash: Boolean = False);
    procedure StreamWriteEndTag(const str: TNameString);
    procedure SetEncoding(const Value: AnsiString);
  protected
    function GetAttribute(const name: TNameString): Variant; override;
    procedure SetAttribute(const name: TNameString; const Value: Variant); override;
    
    procedure _WriteWideChar(const Name: TNameString; Value: WideChar); override;
    procedure _WriteWord(const Name: TNameString; Value: Word); override;
    procedure _WriteDWord(const Name: TNameString; Value: Integer); override;
    procedure _WriteQWord(const Name: TNameString; Value: Int64); override;
  public
    constructor Create; override;
    procedure BeginWriteRootObject(const Name: string); override;
    procedure EndWriteRootObject(const Name: TNameString); override;
    function BeginWriteObject(const Name: TNameString): Boolean; override;
    procedure EndWriteObject(const Name: TNameString); override;
    function BeginWriteList(ListKind: TDataType; ItemCount: Integer): Boolean; override;
    procedure EndWriteList; override;
    function BeginWriteListItem(Index: Integer): Boolean; override;
    procedure EndWriteListItem; override;
    procedure WriteAnsiChar(const Name: TNameString; Value: AnsiChar); override;
    procedure WriteByte(const Name: TNameString; Value: Byte); override;
    procedure WriteFloat(const Name: TNameString; Value: Extended); override;
    procedure WriteAnsiStr(const Name: TNameString; const Value: AnsiString); override;
    procedure WriteWideStr(const Name: TNameString; const Value: WideString); override;
    procedure WriteUTF16Str(const Name: TNameString; const Value: WideString); override;
    procedure WriteAnsiStrListItem(Index: Integer; const Value: AnsiString); override;
    procedure WriteWStrListItem(Index: Integer; const Value: WideString); override;
    procedure WriteUStrListItem(Index: Integer; const Value: WideString); override;
    procedure WritePointer(const Name: TNameString; Buf: Pointer; Len: Integer); override;
    property Encoding: AnsiString read fEncoding write SetEncoding;
    property Declaration: Boolean read fDeclaration write fDeclaration;
  end;
  
implementation

const
  CSTR_COLLECTION_TAG = 'Collection';
  CSTR_COLLECTION_ITEM_TAG = 'CollectionItem';

{ TDzXMLClassReader }

function TDzXMLClassReader.BeginReadList(out Count: Integer): Boolean;
var
  ChildNode: IXMLNode;
begin
  ChildNode := fRootObject.ChildNodes.FindNode(CSTR_COLLECTION_TAG);
  if ChildNode = nil then Result := False
  else begin
    Count := ChildNode.ChildNodes.Count;
    if Count = 0 then Result := False
    else begin
      fRootObject := ChildNode.ChildNodes[0];  
      Result := True;
    end;
  end;
end;

function TDzXMLClassReader.BeginReadListItem(Index: Integer): Boolean;
begin
  Result := Assigned(fRootObject);
end;

function TDzXMLClassReader.BeginReadObject(const Name: TNameString): Boolean;
var
  ChildNode: IXMLNode;
begin
  ChildNode := fRootObject.ChildNodes.FindNode(Name);
  Result := Assigned(ChildNode);
  if Result then fRootObject := ChildNode;
end;

function TDzXMLClassReader.BeginReadRootObject(out Name: TNameString): Boolean;
begin
  LoadFromStream(Stream);
  Name := fRootObject.NodeName;
  Result := True;
end;

procedure TDzXMLClassReader.EndReadList;
begin
  fRootObject := fRootObject.ParentNode;
end;

function TDzXMLClassReader.EndReadListItem: Boolean;
var
  Next: IXMLNode;
begin
  Next := fRootObject.NextSibling;
  if Next = nil then
  begin
    fRootObject := fRootObject.ParentNode;
    Result := False;
  end
  else begin
    fRootObject := fRootObject.NextSibling;
    Result := True;
  end;
end;

procedure TDzXMLClassReader.EndReadObject;
begin
  fRootObject := fRootObject.ParentNode;
end;

procedure TDzXMLClassReader.LoadFromStream(Input: TStream);
begin
  fDocument := NewXMLDocument;
  fDocument.LoadFromStream(Input);
  fRootObject := fDocument.DocumentElement;
end;

function TDzXMLClassReader.ReadAnsiChar(const Name: TNameString;
  out Value: AnsiChar): Boolean;
var
  ChildNode: IXMLNode;
  text: AnsiString;
begin
  ChildNode := fRootObject.ChildNodes.FindNode(Name);
  if ChildNode = nil then Result := False
  else begin
    text := AnsiString(ChildNode.Text);
    if Length(text) = 1 then
    begin
      Value := text[1];
      Result := True;  
    end
    else Result := False
  end;
end;

function TDzXMLClassReader.ReadFloat(const Name: TNameString;
  out Value: Extended): Boolean;
var
  ChildNode: IXMLNode;
begin
  ChildNode := fRootObject.ChildNodes.FindNode(Name);
  if ChildNode = nil then Result := False
  else begin
    Value := StrToFloat(ChildNode.Text);
    Result := True;
  end;
end;

function TDzXMLClassReader.ReadQWord(const Name: TNameString;
  out Value: Int64): Boolean;
var
  ChildNode: IXMLNode;
begin
  ChildNode := fRootObject.ChildNodes.FindNode(Name);
  if ChildNode = nil then Result := False
  else begin
    Value := StrToInt64(ChildNode.Text);
    Result := True;
  end;
end;

function TDzXMLClassReader.ReadDWord(const Name: TNameString;
  out Value: Integer): Boolean;
var
  ChildNode: IXMLNode;
  c: Integer;
begin
  ChildNode := fRootObject.ChildNodes.FindNode(Name);
  if ChildNode = nil then Result := False
  else begin
    Val(ChildNode.Text, Value, c);
    Result := c = 0;
  end;
end;

function TDzXMLClassReader.ReadPointer(const Name: TNameString; Buf: Pointer;
  var Len: Integer): Boolean;
var
  ChildNode: IXMLNode;
  StoreLen: Integer;
begin
  ChildNode := fRootObject.ChildNodes.FindNode(Name);
  if ChildNode = nil then Result := False
  else begin
    Result := True;
    StoreLen := Base64Decode(ChildNode.Text, nil);
    if Buf = nil then
    begin
      Len := StoreLen;
      Exit;
    end;
    if Len > StoreLen then Len := StoreLen;
    Base64Decode(ChildNode.Text, Buf);
  end;
end;

procedure TDzXMLClassReader.ReadPropList(props: TStrings);
var
  i: Integer;
  Nodes: IXMLNodeList;
begin
  Nodes := fRootObject.ChildNodes;
  for i := 0 to Nodes.Count - 1 do props.Add(Nodes[i].NodeName);
end;

function TDzXMLClassReader.ReadUStrListItem(Index: Integer;
  out Value: WideString; out more: Boolean): Boolean;
begin
  Value := fRootObject.Text;
  if (fRootObject.NextSibling = nil) then more := False
  else begin
    fRootObject := fRootObject.NextSibling;
    more := True;
  end;
  Result := True;
end;

function TDzXMLClassReader.ReadUnicodeStr(const Name: TNameString;
  out Value: WideString): Boolean;
var
  ChildNode: IXMLNode;
begin
  ChildNode := fRootObject.ChildNodes.FindNode(Name);
  if ChildNode = nil then Result := False
  else begin
    Value := ChildNode.Text;
    Result := True;
  end;
end;

function TDzXMLClassReader.ReadAnsiStrListItem(Index: Integer;
  out Value: AnsiString; out more: Boolean): Boolean;
begin
  Value := fRootObject.Text;
  if fRootObject.NextSibling = nil then
  begin
    fRootObject := fRootObject.ParentNode;
    more := False;
  end
  else begin
    fRootObject := fRootObject.NextSibling;
    more := True;
  end;
  Result := True;
end;

function TDzXMLClassReader.ReadAnsiStr(const Name: TNameString;
  out Value: AnsiString): Boolean;
var
  ChildNode: IXMLNode;
begin
  ChildNode := fRootObject.ChildNodes.FindNode(Name);
  if ChildNode = nil then Result := False
  else begin
    Value := ChildNode.Text;
    Result := True;
  end;
end;

function TDzXMLClassReader.ReadWideChar(const Name: TNameString;
  out Value: WideChar): Boolean;
var
  ChildNode: IXMLNode;
  text: WideString;
begin
  ChildNode := fRootObject.ChildNodes.FindNode(Name);
  if ChildNode = nil then Result := False
  else begin
    text := WideString(ChildNode.Text);
    if Length(text) = 1 then
    begin
      Value := text[1];
      Result := True;  
    end
    else Result := False;
  end;
end;

function TDzXMLClassReader.ReadWStrListItem(Index: Integer;
  out Value: WideString; out more: Boolean): Boolean;
begin
  Value := fRootObject.Text;
  if fRootObject.NextSibling = nil then more := False
  else begin
    fRootObject := fRootObject.NextSibling;
    more := True;
  end;
  Result := True;
end;

function TDzXMLClassReader.ReadWideStr(const Name: TNameString;
  out Value: WideString): Boolean;
var
  ChildNode: IXMLNode;
begin
  ChildNode := fRootObject.ChildNodes.FindNode(Name);
  if ChildNode = nil then Result := False
  else begin
    Value := ChildNode.Text;
    Result := True;
  end;
end;

procedure TDzXMLClassReader.SetObjectNode(const Value: IXMLNode);
begin
  fDocument := Value.OwnerDocument;
  fRootObject := Value;
end;

{ TDzXMLClassWriter }

function TDzXMLClassWriter.BeginWriteList(ListKind: TDataType;
  ItemCount: Integer): Boolean;
begin
  StreamWriteTag(CSTR_COLLECTION_TAG);
  Result := True;
end;

function TDzXMLClassWriter.BeginWriteListItem(Index: Integer): Boolean;
begin
  StreamWriteTag(CSTR_COLLECTION_ITEM_TAG);
  Result := True;
end;

function TDzXMLClassWriter.BeginWriteObject(const Name: TNameString): Boolean;
begin
  StreamWriteTag(Name);
  Result := True;
end;

procedure TDzXMLClassWriter.EndWriteList;
begin
  StreamWriteEndTag(CSTR_COLLECTION_TAG);
end;

procedure TDzXMLClassWriter.EndWriteObject(const Name: TNameString);
begin
  StreamWriteEndTag(Name);
end;

procedure TDzXMLClassWriter.EndWriteListItem;
begin
  StreamWriteEndTag(CSTR_COLLECTION_ITEM_TAG);
end;

procedure TDzXMLClassWriter.EndWriteRootObject(const Name: TNameString);
begin
  if Length(Name) > 0 then StreamWriteEndTag(Name)
  else StreamWriteEndTag('XMLObject');
end;

function TDzXMLClassWriter.GetAttribute(const name: TNameString): Variant;
const
  ENCODING = 'Encoding';
begin
  if uDZStr.AnsiCompare(@name[1], Length(name), ENCODING, Length(ENCODING),
    [coIgnoreCase]) = crEqual then
    Result := fEncoding
  else Result := inherited GetAttribute(name);
end;

procedure TDzXMLClassWriter.SetAttribute(const name: TNameString; const Value: Variant);
const
  ENCODING = 'Encoding';
begin
  if uDZStr.AnsiCompare(@name[1], Length(name), ENCODING, Length(ENCODING),
    [coIgnoreCase]) = crEqual then
    SetEncoding(Value)
  else inherited SetAttribute(name, value);
end;

procedure TDzXMLClassWriter.SetEncoding(const Value: AnsiString);
var
  cp: Integer;
begin
  if SameText(Value, 'utf-32') then Exit;
  if SameText(Value, 'utf-32BE') then Exit;
  cp := GetCodePageID(Value);
  if (cp > 0) then
  begin
    fEncoding := Value;
    fCodePage := cp;
  end;
end;

procedure TDzXMLClassWriter.StreamWriteAnsi(const str: AnsiString);
begin
  StreamWriteAnsi(PAnsiChar(str), Length(str));
end;

procedure TDzXMLClassWriter.StreamWriteAnsi(const str: PAnsiChar; len: Integer);
var
  wstr: WideString;
  buf: AnsiString;
begin
  if (fCodePage <> CP_UTF8) and (fCodePage <> CP_UTF7) and
    (fCodePage <> CP_UTF16) then
  begin
    Stream.Write(str^, len);
    Exit;
  end;

  SetLength(wstr, len);
  len := mbtowc(str, len, PWideChar(wstr), len);
  if len = 0 then RaiseLastOSError;
  if fCodePage = CP_UTF16 then
    Stream.Write(PWideChar(wstr)^, len * 2)
  else begin
    case fCodePage of
      CP_UTF8: SetLength(buf, len * 3);
      CP_UTF7: SetLength(buf, wctomb(PWideChar(wstr), len, nil, 0, fCodePage));
      else Exit;
    end;
    len := wctomb(PWideChar(wstr), len, PAnsiChar(buf), Length(buf), fCodePage);
    if len = 0 then RaiseLastOSError;
    Stream.Write(Pointer(buf)^, len);
  end;
end;

procedure TDzXMLClassWriter.StreamWriteByte(value: Byte);
begin
  Stream.Write(value, SizeOf(value));
end;

procedure TDzXMLClassWriter.StreamWriteEndTag(const str: TNameString);
const
  LT: AnsiString = '</';
  GT: AnsiString = '>';
begin
  StreamWritePureAnsi(LT);
  StreamWritePureAnsi(@str[1], Length(str));
  StreamWritePureAnsi(GT);
end;

procedure TDzXMLClassWriter.StreamWritePureAnsi(const str: PAnsiChar; len: Integer);
var
  i: Integer;
const
  ZERO: Byte = 0;
begin
  for i := 0 to len - 1 do
  begin
    Stream.Write(str[i], 1);
    if fCodePage = CP_UTF16 then
      Stream.Write(ZERO, 1);
  end;
end;

procedure TDzXMLClassWriter.StreamWritePureAnsi(const str: AnsiString);
begin
  StreamWritePureAnsi(PAnsiChar(str), Length(str));
end;

procedure TDzXMLClassWriter.StreamWriteTag(const str: TNameString; slash: Boolean);
begin
  StreamWritePureAnsi('<');
  StreamWritePureAnsi(@str[1], Length(str));
  if slash then
    StreamWritePureAnsi(' />')
  else
    StreamWritePureAnsi('>');
end;

procedure TDzXMLClassWriter.StreamWriteUnicode(const str: PWideChar; len: Integer);
var
  buf: AnsiString;
begin
  if fCodePage = CP_UTF16 then Stream.Write(str^, len * 2)
  else begin
    case fCodePage of
      CP_UTF8: SetLength(buf, len * 3);
      CP_UTF7: SetLength(buf, wctomb(str, len, nil, 0, fCodePage));
      else SetLength(buf, len * 2);
    end;
    len := wctomb(str, len, PAnsiChar(buf), Length(buf), fCodePage);
    if len = 0 then RaiseLastOSError;
    Stream.Write(Pointer(buf)^, len);
  end;
end;

procedure TDzXMLClassWriter.StreamWriteUnicode(const str: WideString);
begin
  StreamWriteUnicode(PWideChar(str), Length(str));
end;

procedure TDzXMLClassWriter.WriteAnsiChar(const Name: TNameString; Value: AnsiChar);
begin
  StreamWriteTag(Name);
  StreamWritePureAnsi(@Value, 1);
  StreamWriteEndTag(Name);
end;

procedure TDzXMLClassWriter.WriteFloat(const Name: TNameString; Value: Extended);
begin
  StreamWriteTag(Name);
  StreamWritePureAnsi(FloatToStr(Value));
  StreamWriteEndTag(Name);
end;

procedure TDzXMLClassWriter.WritePointer(const Name: TNameString; Buf: Pointer;
  Len: Integer);
begin
  StreamWriteTag(Name);
  StreamWritePureAnsi(Base64Encode(Buf, Len));
  StreamWriteEndTag(Name);
end;

procedure TDzXMLClassWriter._WriteQWord(const Name: TNameString; Value: Int64);
begin
  StreamWriteTag(Name);
  StreamWritePureAnsi(IntToStr(Value));
  StreamWriteEndTag(Name);
end;

procedure TDzXMLClassWriter._WriteDWord(const Name: TNameString; Value: Integer);
begin
  StreamWriteTag(Name);
  StreamWritePureAnsi(IntToStr(Value));
  StreamWriteEndTag(Name);
end;

procedure TDzXMLClassWriter.BeginWriteRootObject(const Name: string);
begin
  AcquireStream;
  if Declaration then WriteDeclaration;
  if Length(Name) > 0 then StreamWriteTag(Name)
  else StreamWriteTag('XMLObject');
end;

constructor TDzXMLClassWriter.Create;
begin
  inherited;
  fCodePage := CP_UTF8;
  fEncoding := GetCodePageName(fCodePage);
  Declaration := True;
end;

procedure TDzXMLClassWriter.WriteUStrListItem(Index: Integer; const Value: WideString);
begin
  if Length(Value) = 0 then
    StreamWriteTag(CSTR_COLLECTION_ITEM_TAG, True)
  else begin
    StreamWriteTag(CSTR_COLLECTION_ITEM_TAG);
    StreamWriteUnicode(Value);
    StreamWriteEndTag(CSTR_COLLECTION_ITEM_TAG);
  end;
end;

procedure TDzXMLClassWriter.WriteUTF16Str(const Name: TNameString; const Value: WideString);
begin
  if Length(Value) = 0 then
    StreamWriteTag(Name, True)
  else begin
    StreamWriteTag(Name);
    StreamWriteUnicode(Value);
    StreamWriteEndTag(Name);
  end;
end;

procedure TDzXMLClassWriter.WriteAnsiStrListItem(Index: Integer; const Value: AnsiString);
begin
  if Length(Value) = 0 then
    StreamWriteTag(CSTR_COLLECTION_ITEM_TAG, True)
  else begin
    StreamWriteTag(CSTR_COLLECTION_ITEM_TAG);
    StreamWriteAnsi(Value);
    StreamWriteEndTag(CSTR_COLLECTION_ITEM_TAG);
  end;
end;

procedure TDzXMLClassWriter.WriteByte(const Name: TNameString; Value: Byte);
begin
  StreamWriteTag(Name);
  StreamWritePureAnsi(IntToStr(Value));
  StreamWriteEndTag(Name);
end;

procedure TDzXMLClassWriter.WriteDeclaration;
begin
  if fCodePage = CP_UTF16 then
  begin
    StreamWriteByte($ff);
    StreamWriteByte($fe);
  end;
  StreamWritePureAnsi('<?xml version="1.0" encoding="');
  StreamWritePureAnsi(fEncoding);
  StreamWritePureAnsi('"?>');
end;

procedure TDzXMLClassWriter.WriteAnsiStr(const Name: TNameString; const Value: AnsiString);
begin
  if Length(Value) = 0 then
    StreamWriteTag(Name, True)
  else begin
    StreamWriteTag(Name);
    StreamWriteAnsi(Value);
    StreamWriteEndTag(Name);
  end;
end;

procedure TDzXMLClassWriter._WriteWideChar(const Name: TNameString; Value: WideChar);
begin
  StreamWriteTag(Name);
  StreamWriteUnicode(@Value, 1);
  StreamWriteEndTag(Name);
end;

procedure TDzXMLClassWriter.WriteWStrListItem(Index: Integer; const Value: WideString);
begin
  if Length(Value) = 0 then
    StreamWriteTag(CSTR_COLLECTION_ITEM_TAG, True)
  else begin
    StreamWriteTag(CSTR_COLLECTION_ITEM_TAG);
    StreamWriteUnicode(Value);
    StreamWriteEndTag(CSTR_COLLECTION_ITEM_TAG);
  end;
end;

procedure TDzXMLClassWriter.WriteWideStr(const Name: TNameString; const Value: WideString);
begin
  if Length(Value) = 0 then
    StreamWriteTag(Name, True)
  else begin
    StreamWriteTag(Name);
    StreamWriteUnicode(Value);
    StreamWriteEndTag(Name);
  end;
end;

procedure TDzXMLClassWriter._WriteWord(const Name: TNameString; Value: Word);
begin
  StreamWriteTag(Name);
  StreamWritePureAnsi(IntToStr(Value));
  StreamWriteEndTag(Name);
end;

end.
